home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mule / mule-diag.el.z / mule-diag.el
Encoding:
Text File  |  1998-05-21  |  26.7 KB  |  773 lines
  1. ;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
  2.  
  3. ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
  4. ;; Licensed to the Free Software Foundation.
  5. ;; Copyright (C) 1997 MORIOKA Tomohiko
  6.  
  7. ;; Keywords: multilingual, charset, coding system, fontset, diagnosis
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24. ;; 02111-1307, USA.
  25.  
  26. ;;; General utility function
  27.  
  28. ;; Print all arguments with single space separator in one line.
  29. (defun print-list (&rest args)
  30.   (while (cdr args)
  31.     (when (car args)
  32.       (princ (car args))
  33.       (princ " "))
  34.     (setq args (cdr args)))
  35.   (princ (car args))
  36.   (princ "\n"))
  37.  
  38. ;; Re-order the elements of charset-list.
  39. (defun sort-charset-list ()
  40.   (setq charset-list
  41.     (sort charset-list
  42.           (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
  43.  
  44. ;;; CHARSET
  45.  
  46. ;;;###autoload
  47. (defun list-character-sets (&optional arg)
  48.   "Display a list of all character sets.
  49.  
  50. The ID column contains a charset identification number for internal use.
  51. The B column contains a number of bytes occupied in a buffer.
  52. The W column contains a number of columns occupied in a screen.
  53.  
  54. With prefix arg, the output format gets more cryptic
  55. but contains full information about each character sets."
  56.   (interactive "P")
  57.   (sort-charset-list)
  58.   (with-output-to-temp-buffer "*Help*"
  59.     (save-excursion
  60.       (set-buffer standard-output)
  61.       (let ((l charset-list)
  62.         charset)
  63.     (if (null arg)
  64.         (progn
  65.           (insert "ID  Name            B W Description\n")
  66.           (insert "--  ----            - - -----------\n")
  67.           (while l
  68.         (setq charset (car l) l (cdr l))
  69.         (insert (format "%03d %s" (charset-id charset) charset))
  70.         (indent-to 28)
  71.         (insert (format "%d %d %s\n"
  72.                 (charset-bytes charset)
  73.                 (charset-width charset)
  74.                 (charset-description charset)))))
  75.       (insert "\
  76. #########################
  77. ## LIST OF CHARSETS
  78. ## Each line corresponds to one charset.
  79. ## The following attributes are listed in this order
  80. ## separated by a colon `:' in one line.
  81. ##    CHARSET-ID,
  82. ##    CHARSET-SYMBOL-NAME,
  83. ##    DIMENSION (1 or 2)
  84. ##    CHARS (94 or 96)
  85. ##    BYTES (of multibyte form: 1, 2, 3, or 4),
  86. ##    WIDTH (occupied column numbers: 1 or 2),
  87. ##    DIRECTION (0:left-to-right, 1:right-to-left),
  88. ##    ISO-FINAL-CHAR (character code of ISO-2022's final character)
  89. ##    ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
  90. ##    DESCRIPTION (describing string of the charset)
  91. ")
  92.       (while l
  93.         (setq charset (car l) l (cdr l))
  94.         (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n" 
  95.                (charset-id charset)
  96.                charset
  97.                (charset-dimension charset)
  98.                (charset-chars charset)
  99.                (charset-bytes charset)
  100.                (charset-width charset)
  101.                (charset-direction charset)
  102.                (charset-iso-final-char charset)
  103.                (charset-iso-graphic-plane charset)
  104.                (charset-description charset))))))
  105.       (help-mode)
  106.       (setq truncate-lines t))))
  107.  
  108. ;;; CODING-SYSTEM
  109.  
  110. (defun describe-designation (cs register)
  111.   (let ((charset
  112.      (coding-system-property
  113.       cs (intern (format "charset-g%d" register))))
  114.     (force
  115.      (coding-system-property
  116.       cs (intern (format "force-g%d-on-output" register)))))
  117.     (princ
  118.      (format
  119.       "  G%d: %s%s\n"
  120.       register
  121.       (cond ((null charset) "never used")
  122.         ((eq t charset) "none")
  123.         (t (charset-name charset)))
  124.       (if force " (explicit designation required)" "")))))
  125.  
  126. ;;;###autoload
  127. (defun describe-coding-system (coding-system)
  128.   "Display information of CODING-SYSTEM."
  129.   (interactive "zDescribe coding system (default, current choices): ")
  130.   (if (or (null coding-system)
  131.       (string= (symbol-name coding-system) ""))
  132.       (describe-current-coding-system)
  133.     (with-output-to-temp-buffer "*Help*"
  134.       (print-coding-system-briefly coding-system 'doc-string)
  135.       (let ((type (coding-system-type coding-system)))
  136.     (princ (format "Type: %s" type))
  137.     (when (eq type 'iso2022)
  138.       (princ " (variant of ISO-2022)\n")
  139.       (princ "Initial designations:\n")
  140.       ;;(print-designation flags)
  141.       (describe-designation coding-system 0)
  142.       (describe-designation coding-system 1)
  143.       (describe-designation coding-system 2)
  144.       (describe-designation coding-system 3)
  145.       (princ "Other Form: \n  ")
  146.       (princ (if (coding-system-short coding-system)
  147.              "short-form"
  148.            "long-form"))
  149.       (if (coding-system-no-ascii-eol coding-system)
  150.           (princ ", ASCII@EOL"))
  151.       (if (coding-system-no-ascii-cntl coding-system)
  152.           (princ ", ASCII@CNTL"))
  153.       (princ (if (coding-system-seven coding-system)
  154.              ", 7-bit"
  155.            ", 8-bit"))
  156.       (if (coding-system-lock-shift coding-system)
  157.           (princ ", use-locking-shift")
  158.         (princ ", use-single-shift"))
  159.       ;;(if (aref flags 10) (princ ", use-roman"))
  160.       ;;(if (aref flags 10) (princ ", use-old-jis"))
  161.       (if (coding-system-no-iso6429 coding-system)
  162.           (princ ", no-ISO6429"))
  163.       )
  164.     (princ "\nEOL type:")
  165.     (let ((eol-type (coding-system-eol-type coding-system)))
  166.       (cond ((null eol-type)
  167.          (princ "\n  Automatic selection from\n    ")
  168.          (princ (format "%s-unix, %s-dos or %s-mac.\n"
  169.                 coding-system coding-system coding-system))
  170.          )
  171.         ((symbolp eol-type)
  172.          (princ " ")
  173.          (princ eol-type))
  174.         (t (princ "invalid\n")))))
  175.       (save-excursion
  176.     (set-buffer standard-output)
  177.     (help-mode)))))
  178.  
  179. ;;;###autoload
  180. (defun describe-current-coding-system-briefly ()
  181.   "Display coding systems currently used in a brief format in echo area.
  182.  
  183. The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
  184. where mnemonics of the following coding systems come in this order
  185. at the place of `..':
  186.   buffer-file-coding-system (of the current buffer)
  187.   eol-type of buffer-file-coding-system (of the current buffer)
  188.   (keyboard-coding-system)
  189.   eol-type of (keyboard-coding-system)
  190.   (terminal-coding-system)
  191.   eol-type of (terminal-coding-system)
  192.   process-coding-system for read (of the current buffer, if any)
  193.   eol-type of process-coding-system for read (of the current buffer, if any)
  194.   process-coding-system for write (of the current buffer, if any)
  195.   eol-type of process-coding-system for write (of the current buffer, if any)
  196.   default-buffer-file-coding-system
  197.   eol-type of default-buffer-file-coding-system
  198.   default-process-coding-system for read
  199.   eol-type of default-process-coding-system for read
  200.   default-process-coding-system for write
  201.   eol-type of default-process-coding-system"
  202.   (interactive)
  203.   (let* ((proc (get-buffer-process (current-buffer)))
  204.      (process-coding-systems (if proc (process-coding-system proc))))
  205.     (message
  206.      "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]"
  207.      (coding-system-mnemonic buffer-file-coding-system)
  208.      (coding-system-eol-type-mnemonic buffer-file-coding-system)
  209.      (coding-system-mnemonic (keyboard-coding-system))
  210.      (coding-system-eol-type-mnemonic (keyboard-coding-system))
  211.      (coding-system-mnemonic (terminal-coding-system))
  212.      (coding-system-eol-type-mnemonic (terminal-coding-system))
  213.      (coding-system-mnemonic (car process-coding-systems))
  214.      (coding-system-eol-type-mnemonic (car process-coding-systems))
  215.      (coding-system-mnemonic (cdr process-coding-systems))
  216.      (coding-system-eol-type-mnemonic (cdr process-coding-systems))
  217.      (coding-system-mnemonic default-buffer-file-coding-system)
  218.      (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
  219.      (coding-system-mnemonic (car default-process-coding-system))
  220.      (coding-system-eol-type-mnemonic (car default-process-coding-system))
  221.      (coding-system-mnemonic (cdr default-process-coding-system))
  222.      (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
  223.      )))
  224.  
  225. ;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'.
  226. (defun print-coding-system-briefly (coding-system &optional doc-string)
  227.   (if (not coding-system)
  228.       (princ "nil\n")
  229.     ;; In XEmacs, coding-system has own type.
  230.     (if (coding-system-p coding-system)
  231.     (setq coding-system (coding-system-name coding-system))
  232.       )
  233.     ;; In XEmacs, coding-system-mnemonic returns string.
  234.     (princ (format "%s -- %s"
  235.            (coding-system-mnemonic coding-system)
  236.            coding-system))
  237.     ;; Current XEmacs does not have `coding-system-parent'.
  238.     ;; (let ((parent (coding-system-parent coding-system)))
  239.     ;;   (if parent
  240.     ;;       (princ (format " (alias of %s)" parent))))
  241.     (let ((aliases (get coding-system 'alias-coding-systems)))
  242.       (if aliases
  243.       (princ (format " %S" (cons 'alias: aliases)))))
  244.     (princ "\n")
  245.     (if (and doc-string
  246.          (setq doc-string (coding-system-doc-string coding-system)))
  247.     (princ (format "  %s\n" doc-string)))))
  248.  
  249. ;;;###autoload
  250. (defun describe-current-coding-system ()
  251.   "Display coding systems currently used in a detailed format."
  252.   (interactive)
  253.   (with-output-to-temp-buffer "*Help*"
  254.     (let* ((proc (get-buffer-process (current-buffer)))
  255.        (process-coding-systems (if proc (process-coding-system proc))))
  256.       (princ "Coding system for saving this buffer:\n  ")
  257.       ;; local-variable-p of XEmacs requires 2 arguments.
  258.       (if (local-variable-p 'buffer-file-coding-system (current-buffer))
  259.       (print-coding-system-briefly buffer-file-coding-system)
  260.     (princ "Not set locally, use the default.\n"))
  261.       (princ "Default coding system (for new files):\n  ")
  262.       (print-coding-system-briefly default-buffer-file-coding-system)
  263.       (princ "Coding system for keyboard input:\n  ")
  264.       (print-coding-system-briefly (keyboard-coding-system))
  265.       (princ "Coding system for terminal output:\n  ")
  266.       (print-coding-system-briefly (terminal-coding-system))
  267.       (when (get-buffer-process (current-buffer))
  268.     (princ "Coding systems for process I/O:\n")
  269.     (princ "  encoding input to the process: ")
  270.     (print-coding-system-briefly (cdr process-coding-systems))
  271.     (princ "  decoding output from the process: ")
  272.     (print-coding-system-briefly (car process-coding-systems)))
  273.       ;;(princ "Defaults for subprocess I/O:\n")
  274.       ;;(princ "  decoding: ")
  275.       ;;(print-coding-system-briefly (car default-process-coding-system))
  276.       ;;(princ "  encoding: ")
  277.       ;;(print-coding-system-briefly (cdr default-process-coding-system))
  278.       )
  279.     (save-excursion
  280.       (set-buffer standard-output)
  281.  
  282.       (princ
  283.        "\nPriority order for recognizing coding systems when reading files:\n")
  284.       (let ((l (coding-category-list)) ; It is function in XEmacs.
  285.         (i 1)
  286.         (coding-list nil)
  287.         coding aliases)
  288.     (while l
  289.       (setq coding (coding-category-system (car l))) ; for XEmacs
  290.       (when (not (memq coding coding-list))
  291.         (setq coding-list (cons coding coding-list))
  292.         (princ (format "  %d. %s" i coding))
  293.         (when (setq aliases (get coding 'alias-coding-systems))
  294.           (princ " ")
  295.           (princ (cons 'alias: aliases)))
  296.         (terpri)
  297.         (setq i (1+ i)))
  298.       (setq l (cdr l))))
  299.       (princ "\n  Other coding systems cannot be distinguished automatically
  300.   from these, and therefore cannot be recognized automatically
  301.   with the present coding system priorities.\n\n")
  302.  
  303.       (let ((categories '(iso-7)) ; for XEmacs
  304.         ;; '(coding-category-iso-7 coding-category-iso-7-else))
  305.         coding-system codings)
  306.     (while categories
  307.       ;; for XEmacs
  308.       (setq coding-system (coding-category-system (car categories)))
  309.       (mapcar
  310.        (function
  311.         (lambda (x)
  312.           (if (and (not (eq x coding-system))
  313.                (get x 'no-initial-designation)
  314.                (let ((flags (coding-system-flags x)))
  315.              (not (or (aref flags 10) (aref flags 11)))))
  316.           (setq codings (cons x codings)))))
  317.        (get (car categories) 'coding-systems))
  318.       (if codings
  319.           (let ((max-col (frame-width))
  320.             pos)
  321.         (princ (format "  The followings are decoded correctly but recognized as %s:\n   " coding-system))
  322.         (while codings
  323.           (setq pos (point))
  324.           (insert (format " %s" (car codings)))
  325.           (when (> (current-column) max-col)
  326.             (goto-char pos)
  327.             (insert "\n   ")
  328.             (goto-char (point-max)))
  329.           (setq codings (cdr codings)))
  330.         (insert "\n\n")))
  331.       (setq categories (cdr categories))))
  332.  
  333.       (princ "Particular coding systems specified for certain file names:\n")
  334.       (terpri)
  335.       (princ "  OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
  336.       (princ "  ---------\t--------------\t\t----------------\n")
  337.       (let ((func (lambda (operation alist)
  338.             (princ "  ")
  339.             (princ operation)
  340.             (if (not alist)
  341.             (princ "\tnothing specified\n")
  342.               (while alist
  343.             (indent-to 16)
  344.             (prin1 (car (car alist)))
  345.             (indent-to 40)
  346.             (princ (cdr (car alist)))
  347.             (princ "\n")
  348.             (setq alist (cdr alist)))))))
  349.     (funcall func "File I/O" file-coding-system-alist)
  350.     (funcall func "Process I/O" process-coding-system-alist)
  351.     (funcall func "Network I/O" network-coding-system-alist))
  352.       (help-mode))))
  353.  
  354. ;; Print detailed information on CODING-SYSTEM.
  355. (defun print-coding-system (coding-system &optional aliases)
  356.   (let ((type (coding-system-type coding-system))
  357.     (eol-type (coding-system-eol-type coding-system))
  358.     (flags (coding-system-flags coding-system))
  359.     (base (coding-system-base coding-system)))
  360.     (if (not (eq base coding-system))
  361.     (princ (format "%s (alias of %s)\n" coding-system base))
  362.       (princ coding-system)
  363.       (while aliases
  364.     (princ ",")
  365.     (princ (car aliases))
  366.     (setq aliases (cdr aliases)))
  367.       (princ (format ":%s:%c:%d:"
  368.              type
  369.              (coding-system-mnemonic coding-system)
  370.              (if (integerp eol-type) eol-type 3)))
  371.       (cond ((eq type 2)        ; ISO-2022
  372.          (let ((idx 0)
  373.            charset)
  374.            (while (< idx 4)
  375.          (setq charset (aref flags idx))
  376.          (cond ((null charset)
  377.             (princ -1))
  378.                ((eq charset t)
  379.             (princ -2))
  380.                ((charsetp charset)
  381.             (princ charset))
  382.                ((listp charset)
  383.             (princ "(")
  384.             (princ (car charset))
  385.             (setq charset (cdr charset))
  386.             (while charset
  387.               (princ ",")
  388.               (princ (car charset))
  389.               (setq charset (cdr charset)))
  390.             (princ ")")))
  391.          (princ ",")
  392.          (setq idx (1+ idx)))
  393.            (while (< idx 12)
  394.          (princ (if (aref flags idx) 1 0))
  395.          (princ ",")
  396.          (setq idx (1+ idx)))
  397.            (princ (if (aref flags idx) 1 0))))
  398.         ((eq type 4)        ; CCL
  399.          (let (i len)
  400.            (setq i 0 len (length (car flags)))
  401.            (while (< i len)
  402.          (princ (format " %x" (aref (car flags) i)))
  403.          (setq i (1+ i)))
  404.            (princ ",")
  405.            (setq i 0 len (length (cdr flags)))
  406.            (while (< i len)
  407.          (princ (format " %x" (aref (cdr flags) i)))
  408.          (setq i (1+ i)))))
  409.         (t (princ 0)))
  410.       (princ ":")
  411.       (princ (coding-system-doc-string coding-system))
  412.       (princ "\n"))))
  413.  
  414. ;;;###autoload
  415. (defun list-coding-systems (&optional arg)
  416.   "Display a list of all coding systems.
  417. It prints mnemonic letter, name, and description of each coding systems.
  418.  
  419. With prefix arg, the output format gets more cryptic,
  420. but contains full information about each coding systems."
  421.   (interactive "P")
  422.   (with-output-to-temp-buffer "*Help*"
  423.     (if (null arg)
  424.     (princ "\
  425. ###############################################
  426. # List of coding systems in the following format:
  427. # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
  428. #    DOC-STRING
  429. ")
  430.       (princ "\
  431. #########################
  432. ## LIST OF CODING SYSTEMS
  433. ## Each line corresponds to one coding system
  434. ## Format of a line is:
  435. ##   NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
  436. ##    :PRE-WRITE-CONVERSION:DOC-STRING,
  437. ## where
  438. ##  NAME = coding system name
  439. ##  ALIAS = alias of the coding system
  440. ##  TYPE = nil (no conversion), t (undecided or automatic detection),
  441. ##         0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
  442. ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
  443. ##  FLAGS =
  444. ##    if TYPE = 2 then
  445. ##      comma (`,') separated data of the followings:
  446. ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
  447. ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
  448. ##    else if TYPE = 4 then
  449. ##      comma (`,') separated CCL programs for read and write
  450. ##    else
  451. ##      0
  452. ##  POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
  453. ##
  454. "))
  455.     (let ((bases (coding-system-list))
  456.       ;;(coding-system-list 'base-only))
  457.             coding-system)
  458.       (while bases
  459.     (setq coding-system (car bases))
  460.     (if (null arg)
  461.         (print-coding-system-briefly coding-system 'doc-string)
  462.       (print-coding-system coding-system))
  463.     (setq bases (cdr bases))))))
  464.  
  465. ;;;###automatic
  466. (defun list-coding-categories ()
  467.   "Display a list of all coding categories."
  468.   (with-output-to-temp-buffer "*Help*"
  469.     (princ "\
  470. ############################
  471. ## LIST OF CODING CATEGORIES (ordered by priority)
  472. ## CATEGORY:CODING-SYSTEM
  473. ##
  474. ")
  475.     (let ((l coding-category-list))
  476.       (while l
  477.     (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
  478.     (setq l (cdr l))))))
  479.  
  480. ;;; FONT
  481.  
  482. ;; Print information of a font in FONTINFO.
  483. (defun describe-font-internal (font-info &optional verbose)
  484.   (print-list "name (opened by):" (aref font-info 0))
  485.   (print-list "       full name:" (aref font-info 1))
  486.   (let ((charset (aref font-info 2)))
  487.     (print-list "   charset:"
  488.         (format "%s (%s)" charset (charset-description charset))))
  489.   (print-list "            size:" (format "%d" (aref font-info 3)))
  490.   (print-list "          height:" (format "%d" (aref font-info 4)))
  491.   (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
  492.   (print-list "relative-compose:" (format "%d" (aref font-info 6))))
  493.  
  494. ;;;###autoload
  495. (defun describe-font (fontname)
  496.   "Display information about fonts which partially match FONTNAME."
  497.   (interactive "sFontname (default, current choise for ASCII chars): ")
  498.   (or window-system
  499.       (error "No window system being used"))
  500.   (when (or (not fontname) (= (length fontname) 0))
  501.     (setq fontname (cdr (assq 'font (frame-parameters))))
  502.     (if (query-fontset fontname)
  503.     (setq fontname
  504.           (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
  505.   (let ((font-info (font-info fontname)))
  506.     (if (null font-info)
  507.     (message "No matching font")
  508.       (with-output-to-temp-buffer "*Help*"
  509.     (describe-font-internal font-info 'verbose)))))
  510.  
  511. ;; Print information of FONTSET.  If optional arg PRINT-FONTS is
  512. ;; non-nil, print also names of all fonts in FONTSET.  This function
  513. ;; actually INSERT such information in the current buffer.
  514. (defun print-fontset (fontset &optional print-fonts)
  515.   (let* ((fontset-info (fontset-info fontset))
  516.      (size (aref fontset-info 0))
  517.      (height (aref fontset-info 1))
  518.      (fonts (and print-fonts (aref fontset-info 2)))
  519.      (xlfd-fields (x-decompose-font-name fontset))
  520.      style)
  521.     (if xlfd-fields
  522.     (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
  523.           (slant  (aref xlfd-fields xlfd-regexp-slant-subnum)))
  524.       (if (string-match "^bold$\\|^demibold$" weight)
  525.           (setq style (concat weight " "))
  526.         (setq style "medium "))
  527.       (cond ((string-match "^i$" slant)
  528.          (setq style (concat style "italic")))
  529.         ((string-match "^o$" slant)
  530.          (setq style (concat style "slant")))
  531.         ((string-match "^ri$" slant)
  532.          (setq style (concat style "reverse italic")))
  533.         ((string-match "^ro$" slant)
  534.          (setq style (concat style "reverse slant")))))
  535.       (setq style " ? "))
  536.     (beginning-of-line)
  537.     (insert fontset)
  538.     (indent-to 58)
  539.     (insert (if (> size 0) (format "%2dx%d" size height) "  -"))
  540.     (indent-to 64)
  541.     (insert style "\n")
  542.     (when print-fonts
  543.       (insert "  O Charset / Fontname\n"
  544.           "  - ------------------\n")
  545.       (sort-charset-list)
  546.       (let ((l charset-list)
  547.         charset font-info opened fontname)
  548.     (while l
  549.       (setq charset (car l) l (cdr l))
  550.       (setq font-info (assq charset fonts))
  551.       (if (null font-info)
  552.           (setq opened ?? fontname "not specified")
  553.         (if (nth 2 font-info)
  554.         (if (stringp (nth 2 font-info))
  555.             (setq opened ?o fontname (nth 2 font-info))
  556.           (setq opened ?- fontname (nth 1 font-info)))
  557.           (setq opened ?x fontname (nth 1 font-info))))
  558.       (insert (format "  %c %s\n    %s\n"
  559.               opened charset fontname)))))))
  560.  
  561. ;;;###autoload
  562. (defun describe-fontset (fontset)
  563.   "Display information of FONTSET.
  564.  
  565. It prints name, size, and style of FONTSET, and lists up fonts
  566. contained in FONTSET.
  567.  
  568. The column WDxHT contains width and height (pixels) of each fontset
  569. \(i.e. those of ASCII font in the fontset).  The letter `-' in this
  570. column means that the corresponding fontset is not yet used in any
  571. frame.
  572.  
  573. The O column of each font contains one of the following letters.
  574.  o -- font already opened
  575.  - -- font not yet opened
  576.  x -- font can't be opened
  577.  ? -- no font specified
  578.  
  579. The Charset column of each font contains a name of character set
  580. displayed by the font."
  581.   (interactive
  582.    (if (not window-system)
  583.        (error "No window system being used")
  584.      (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
  585.        (completion-ignore-case t))
  586.        (list (completing-read
  587.           "Fontset (default, used by the current frame): "
  588.           fontset-list nil t)))))
  589.   (if (= (length fontset) 0)
  590.       (setq fontset (cdr (assq 'font (frame-parameters)))))
  591.   (if (not (query-fontset fontset))
  592.       (error "Current frame is using font, not fontset"))
  593.   (let ((fontset-info (fontset-info fontset)))
  594.     (with-output-to-temp-buffer "*Help*"
  595.       (save-excursion
  596.     (set-buffer standard-output)
  597.     (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
  598.     (insert "------------\t\t\t\t\t\t  ----- -----\n")
  599.     (print-fontset fontset t)))))
  600.  
  601. ;;;###autoload
  602. (defun list-fontsets (arg)
  603.   "Display a list of all fontsets.
  604.  
  605. It prints name, size, and style of each fontset.
  606. With prefix arg, it also lists up fonts contained in each fontset.
  607. See the function `describe-fontset' for the format of the list."
  608.   (interactive "P")
  609.   (with-output-to-temp-buffer "*Help*"
  610.     (save-excursion
  611.       (set-buffer standard-output)
  612.       (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
  613.       (insert "------------\t\t\t\t\t\t  ----- -----\n")
  614.       (let ((fontsets (fontset-list)))
  615.     (while fontsets
  616.       (print-fontset (car fontsets) arg)
  617.       (setq fontsets (cdr fontsets)))))))
  618.  
  619. ;;;###autoload
  620. (defun list-input-methods ()
  621.   "Print information of all input methods."
  622.   (interactive)
  623.   (with-output-to-temp-buffer "*Help*"
  624.     (princ "LANGUAGE\n  NAME (`TITLE' in mode line)\n")
  625.     (princ "    SHORT-DESCRIPTION\n------------------------------\n")
  626.     (setq input-method-alist
  627.       (sort input-method-alist
  628.         (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
  629.     (let ((l input-method-alist)
  630.       language elt)
  631.       (while l
  632.     (setq elt (car l) l (cdr l))
  633.     (when (not (equal language (nth 1 elt)))
  634.       (setq language (nth 1 elt))
  635.       (princ language)
  636.       (terpri))
  637.     (princ (format "  %s (`%s' in mode line)\n    %s\n"
  638.                (car elt) (nth 3 elt)
  639.                (let ((title (nth 4 elt)))
  640.              (string-match ".*" title)
  641.              (match-string 0 title))))))))
  642.  
  643. ;;; DIAGNOSIS
  644.  
  645. ;; Insert a header of a section with SECTION-NUMBER and TITLE.
  646. (defun insert-section (section-number title)
  647.   (insert "########################################\n"
  648.       "# Section " (format "%d" section-number) ".  " title "\n"
  649.       "########################################\n\n"))
  650.  
  651. ;;;###autoload
  652. (defun mule-diag ()
  653.   "Display diagnosis of the multilingual environment (MULE).
  654.  
  655. It prints various information related to the current multilingual
  656. environment, including lists of input methods, coding systems,
  657. character sets, and fontsets (if Emacs running under some window
  658. system)."
  659.   (interactive)
  660.   (with-output-to-temp-buffer "*Mule-Diagnosis*"
  661.     (save-excursion
  662.       (set-buffer standard-output)
  663.       (insert "\t###############################\n"
  664.           "\t### Diagnosis of your Emacs ###\n"
  665.           "\t###############################\n\n"
  666.           "CONTENTS: Section 1.  General Information\n"
  667.           "          Section 2.  Display\n"
  668.           "          Section 3.  Input methods\n"
  669.           "          Section 4.  Coding systems\n"
  670.           "          Section 5.  Character sets\n")
  671.       (if window-system
  672.       (insert "          Section 6.  Fontsets\n"))
  673.       (insert "\n")
  674.  
  675.       (insert-section 1 "General Information")
  676.       (insert "Version of this emacs:\n  " (emacs-version) "\n\n")
  677.  
  678.       (insert-section 2 "Display")
  679.       (if window-system
  680.       (insert "Window-system: "
  681.           (symbol-name window-system)
  682.           (format "%s" window-system-version))
  683.     (insert "Terminal: " (getenv "TERM")))
  684.       (insert "\n\n")
  685.  
  686.       (if (eq window-system 'x)
  687.       (let ((font (cdr (assq 'font (frame-parameters)))))
  688.         (insert "The selected frame is using the "
  689.             (if (query-fontset font) "fontset" "font")
  690.             ":\n\t" font))
  691.     (insert "Coding system of the terminal: "
  692.         (symbol-name (terminal-coding-system))))
  693.       (insert "\n\n")
  694.  
  695.       (insert-section 3 "Input methods")
  696.       (save-excursion (list-input-methods))
  697.       (insert-buffer-substring "*Help*")
  698.       (insert "\n")
  699.       (if default-input-method
  700.       (insert "Default input method: " default-input-method "\n")
  701.     (insert "No default input method is specified\n"))
  702.  
  703.       (insert-section 4 "Coding systems")
  704.       (save-excursion (list-coding-systems t))
  705.       (insert-buffer-substring "*Help*")
  706.       (save-excursion (list-coding-categories))
  707.       (insert-buffer-substring "*Help*")
  708.       (insert "\n")
  709.  
  710.       (insert-section 5 "Character sets")
  711.       (save-excursion (list-character-sets t))
  712.       (insert-buffer-substring "*Help*")
  713.       (insert "\n")
  714.  
  715.       (when window-system
  716.     (insert-section 6 "Fontsets")
  717.     (save-excursion (list-fontsets t))
  718.     (insert-buffer-substring "*Help*"))
  719.       (help-mode))))
  720.  
  721.  
  722. ;;; DUMP DATA FILE
  723.  
  724. ;;;###autoload
  725. (defun dump-charsets ()
  726.   "Dump information of all charsets into the file \"CHARSETS\".
  727. The file is saved in the directory `data-directory'."
  728.   (let ((file (expand-file-name "CHARSETS" data-directory))
  729.     buf)
  730.     (or (file-writable-p file)
  731.     (error "Can't write to file %s" file))
  732.     (setq buf (find-file-noselect file))
  733.     (save-window-excursion
  734.       (save-excursion
  735.     (set-buffer buf)
  736.     (setq buffer-read-only nil)
  737.     (erase-buffer)
  738.     (list-character-sets t)
  739.     (insert-buffer-substring "*Help*")
  740.     (let (make-backup-files
  741.           coding-system-for-write)
  742.       (save-buffer))))
  743.     (kill-buffer buf))
  744.   (if noninteractive
  745.       (kill-emacs)))
  746.  
  747. ;;;###autoload
  748. (defun dump-codings ()
  749.   "Dump information of all coding systems into the file \"CODINGS\".
  750. The file is saved in the directory `data-directory'."
  751.   (let ((file (expand-file-name "CODINGS" data-directory))
  752.     buf)
  753.     (or (file-writable-p file)
  754.     (error "Can't write to file %s" file))
  755.     (setq buf (find-file-noselect file))
  756.     (save-window-excursion
  757.       (save-excursion
  758.     (set-buffer buf)
  759.     (setq buffer-read-only nil)
  760.     (erase-buffer)
  761.     (list-coding-systems t)
  762.     (insert-buffer-substring "*Help*")
  763.     (list-coding-categories)
  764.     (insert-buffer-substring "*Help*")
  765.     (let (make-backup-files
  766.           coding-system-for-write)
  767.       (save-buffer))))
  768.     (kill-buffer buf))
  769.   (if noninteractive
  770.       (kill-emacs)))
  771.  
  772. ;;; mule-diag.el ends here
  773.